;;########################################################################
;; workmap1.lsp
;; code to implement iconmap object and methods for workmap and guidemap
;; Copyright (c) 1992-99 by Forrest W. Young
;;########################################################################

(defproto iconmap-proto
  '(num-icons         icon-list     connection-list   x  y setting-margin
    icon-number-list  redraw-order  selected-icon     previously-selected-icon
    toolbar           gui           icon-type         icon-title lines 
    guidemap-number   postpone-redraw  short-icon-titles ;help-overlay
    new-icon-style?   icon-spacing? resizing?         vista-rect
    calculate-vista-rect?           icon-title-color  icon-title-boxes 
    zig-zag           deleted?      connections-to-me last-me
    connection-line-list  deleted-icon-number-list    num-toolbar-buts
    show-icon-ears?   show-extensions? toolbar-obj    window-height 
    window-width      active-window? ) 
  nil graph-proto)

(defmeth iconmap-proto :isnew (&rest args)
  (setf *old-time*  0)
  ;(setf *bottom-line* nil)
  ;(setf *now-bottom-line* (bottom-line))
  (apply #'call-next-method args)
  (send self :num-icons 0)
  (when *logo* (send *logo* :line-data))
  (send self :calculate-vista-rect)
  (send self :icon-title-color 'white)
#+color (when (> *color-mode* 0) (send self :use-color t))
 ; (send self :back-color 'workmap-background)
  )

(defmeth iconmap-proto :size (&optional (width nil width?) (height nil height?))
  (if width? 
      (if height? 
          (setf (slot-value 'size) (list width height))
          (error "you must specify both height and width")))
  (let* ((size (slot-value 'size))
         (w (first size))
         (w (if w (max (list 50 w)) 50))
         (h (second size))
         (h (if h (max (list 50 h)) 50)))
    (list w h)))

(defmeth iconmap-proto :num-icons (&optional (val nil set))
  (if set (setf (slot-value 'num-icons) val))
  (slot-value 'num-icons))

(defmeth iconmap-proto :icon-list (&optional (val nil set))
  (if set (setf (slot-value 'icon-list) val))
  (slot-value 'icon-list))

(defmeth iconmap-proto :icon-number-list (&optional (val nil set))
  (if set (setf (slot-value 'icon-number-list) val))
  (slot-value 'icon-number-list))

(defmeth iconmap-proto :deleted-icon-number-list (&optional (val nil set))
  (if set (setf (slot-value 'deleted-icon-number-list) val))
  (slot-value 'deleted-icon-number-list))

(defmeth iconmap-proto :connection-list (&optional (list nil set))
  (if set (setf (slot-value 'connection-list) list))
  (slot-value 'connection-list))

(defmeth iconmap-proto :connection-line-list (&optional (list nil set))
  (if set (setf (slot-value 'connection-line-list) list))
  (slot-value 'connection-line-list))

(defmeth iconmap-proto :connections-to-me (&optional (list nil set))
  (if set (setf (slot-value 'connections-to-me) list))
  (slot-value 'connections-to-me))

(defmeth iconmap-proto :redraw-order (&optional (val nil set))
  (if set (setf (slot-value 'redraw-order) val))
  (slot-value 'redraw-order))

(defmeth iconmap-proto :x (&optional (val nil set))
  (if set (setf (slot-value 'x) val))
  (slot-value 'x))

(defmeth iconmap-proto :y (&optional (val nil set))
  (if set (setf (slot-value 'y) val))
  (slot-value 'y))

(defmeth iconmap-proto :icon-type (&optional (val nil set))
  (if set (setf (slot-value 'icon-type) val))
  (slot-value 'icon-type))

(defmeth iconmap-proto :icon-title (&optional (string nil set))
  (if set (setf (slot-value 'icon-title) string))
  (slot-value 'icon-title))

(defmeth iconmap-proto :selected-icon (&optional (icon-number nil set))
  (if set (setf (slot-value 'selected-icon) icon-number))
  (slot-value 'selected-icon))

(defmeth iconmap-proto :previously-selected-icon (&optional (icon-number nil set))
  (if set (setf (slot-value 'previously-selected-icon) icon-number))
  (slot-value 'previously-selected-icon))

(defmeth iconmap-proto :toolbar (&optional (logical nil set))
"Concerns whether map has toolbar (T or NIL)"
  (if set (setf (slot-value 'toolbar) logical))
  (slot-value 'toolbar))

(defmeth iconmap-proto :toolbar-obj (&optional (objid nil set))
"Toolbar Object ID"
  (if set (setf (slot-value 'toolbar-obj) objid))
  (slot-value 'toolbar-obj))

(defmeth iconmap-proto :gui (&optional (logical nil set))
  (if set (setf (slot-value 'gui) logical))
  (slot-value 'gui))

(defmeth iconmap-proto :new-icon-style? (&optional (logical nil set))
  (if set (setf (slot-value 'new-icon-style?) logical))
  (slot-value 'new-icon-style?))

(defmeth iconmap-proto :icon-spacing? (&optional (logical nil set))
  (if set (setf (slot-value 'icon-spacing?) logical))
  (slot-value 'icon-spacing?))

(defmeth iconmap-proto :deleted? (&optional (logical nil set))
  (if set (setf (slot-value 'deleted?) logical))
  (slot-value 'deleted?))

;(defmeth iconmap-proto :help-overlay (&optional (object nil set))
;  (if set (setf (slot-value 'help-overlay) object))
;  (slot-value 'help-overlay))

(defmeth iconmap-proto :guidemap-number (&optional (number nil set))
"Message args: (&optional number)
 Sets or retrieves the guidemap number (used for identification)." 
  (if set (setf (slot-value 'guidemap-number) number))
  (slot-value 'guidemap-number))

(defmeth iconmap-proto :last-me (&optional (number nil set))
"Message args: (&optional number)
 Sets or retrieves the last-me number (used for upward disconnects)." 
  (if set (setf (slot-value 'last-me) number))
  (slot-value 'last-me))

(defmeth iconmap-proto :postpone-redraw (&optional (logical nil set))
"Message args: (&optional logical)
 Sets or retrieves whether to postpone redraw." 
  (if set (setf (slot-value 'postpone-redraw) logical))
  (slot-value 'postpone-redraw))

(defmeth iconmap-proto :short-icon-titles (&optional (logical nil set))
  (if set (setf (slot-value 'short-icon-titles) logical))
  (slot-value 'short-icon-titles))

(defmeth iconmap-proto :setting-margin (&optional (logical nil set))
  (if set (setf (slot-value 'setting-margin ) logical))
  (slot-value 'setting-margin ))

(defmeth iconmap-proto :resizing? (&optional (logical nil set))
  (if set (setf (slot-value 'resizing? ) logical))
  (slot-value 'resizing?  ))

(defmeth iconmap-proto :calculate-vista-rect? (&optional (logical nil set)) 
  (if set (setf (slot-value 'calculate-vista-rect?) logical))
  (slot-value 'calculate-vista-rect?))

(defmeth iconmap-proto :icon-title-boxes (&optional (logical nil set)) 
  (if set (setf (slot-value 'icon-title-boxes) logical))
  (slot-value 'icon-title-boxes))

(defmeth iconmap-proto :icon-title-color (&optional (logical nil set)) 
  (if set (setf (slot-value 'icon-title-color) logical))
  (slot-value 'icon-title-color))

(defmeth iconmap-proto :zig-zag (&optional (logical nil set)) 
  (if set (setf (slot-value 'zig-zag) logical))
  (slot-value 'zig-zag))

(defmeth iconmap-proto :lines (&optional (list nil set))
  (if set (setf (slot-value 'lines) list))
  (slot-value 'lines))

(defmeth iconmap-proto :vista-rect (&optional (list nil set))
  (if set (setf (slot-value 'vista-rect) list))
  (slot-value 'vista-rect))

(defmeth iconmap-proto :num-toolbar-buts (&optional (value nil set))
  (if set (setf (slot-value 'num-toolbar-buts) value))
  (slot-value 'num-toolbar-buts))

(defmeth iconmap-proto :show-icon-ears? (&optional (logical nil set)) 
  (if set (setf (slot-value 'show-icon-ears?) logical))
  (slot-value 'show-icon-ears?))

(defmeth iconmap-proto :show-extensions? (&optional (logical nil set)) 
  (if set (setf (slot-value 'show-extensions?) logical))
  (slot-value 'show-extensions?))

(defmeth iconmap-proto :window-width (&optional (value nil set))
  (if set (setf (slot-value 'window-width) value))
  (slot-value 'window-width))

(defmeth iconmap-proto :window-height (&optional (value nil set))
  (if set (setf (slot-value 'window-height) value))
  (slot-value 'window-height))

(defmeth iconmap-proto :active-window? (&optional (logical nil set))
  (if set (setf (slot-value 'active-window?) logical))
  (slot-value 'active-window?))

(defmeth iconmap-proto :draw-icon (icon state x y)
  (send icon :x x)
  (send icon :y y)
  (send icon :show-icon state))

(defmeth iconmap-proto :selected-icon-object ()
     (select (send self :icon-list) (send self :selected-icon)))

(defmeth iconmap-proto :previously-selected-icon-object ()
     (select (send self :icon-list) (send self :previously-selected-icon)))


(defmeth iconmap-proto :redraw-icons ()
  (let* ((previconobj (send *workmap* :previously-selected-icon-object))
         (curriconobj (send *workmap* :selected-icon-object)))
    (when (and previconobj (not (send previconobj :state "normal")))
          (send previconobj :turn-title-off)
          (send previconobj :state "normal")
          (send previconobj :redraw))
    ))

(setf nworkdraws 0)

(defun bottom-line (&optional string-list)
"Arg: &optional string-list
Writes text to bottom of workmap."
  (cond
    (string-list
     (setf *bottom-line* (if (stringp string-list) (list string-list) string-list ))
     (send *workmap* :draw-bottom-line)
     )
    ((< (- (run-time) *deskup-time*) .1)
     (send *workmap* :draw-copyright))
    (t
     (send *workmap* :draw-time))))
 
(defun bottom-line (&optional string-list))     

(setf *bottom-line-buffer* nil)

(defmeth iconmap-proto :draw-time ()
  (setf *bottom-line* (list (time-string))))

(defun time-string ()
  (let ((date-time (date-time)))
    (strcat (third date-time) ", " 
            (first date-time) ", " 
            (second date-time) " (Elapsed: "
            (elapsed-time) ")"
            )))

(defmeth iconmap-proto :draw-copyright ()
  (setf *bottom-line* (list *vista-name* *copyright-string*)))

(defmeth iconmap-proto :draw-bottom-line (&optional (text-list *bottom-line*))
  (when *bottom-line*
        (let* ((w (first (send self :size)))
               (nlines (length text-list))
               (th (+ (send self :text-ascent) (send self :text-descent) -1 ))
               (y (- (second (send self :size)) (* (- nlines 1) (+ 1 th)) 3))
               (x (floor (/ (first (send self :size)) 2)))
               (x 120)
               (cw (send self :canvas-width))
               (scroll-x (first (send self :scroll)))
               (has-h-scroll (send self :has-h-scroll))
               (b (- (second (send self :size)) (if has-h-scroll 23 8)))
               )
          (send self :line-width 2)
          (send self :draw-line 0 b cw b)
          (send self :line-width 1)
          (when *bottom-line-buffer* 
                (send self :draw-mode 'xor)
                (mapcar #'(lambda (line n) 
                            (send self :draw-text line 
                                  (+ scroll-x x)  (+ y (if has-h-scroll -15 +1) (* (1+ n) th))
                                  0 1))
                        *bottom-line-buffer* (iseq (length *bottom-line-buffer*)))
                (send self :draw-mode 'normal))
          (mapcar #'(lambda (line n) 
                      (send self :draw-text line 
                            (+ scroll-x x) (+ y (if has-h-scroll -15 +1) (* (1+ n) th))
                            0 1))
                  text-list (iseq nlines))
          (setf *bottom-line-buffer* *bottom-line*))))

(defmeth iconmap-proto :draw-bottom-line (&rest args))

(defun make-current-object-info-line ()
  (setf *ol* (one-liner (strcat "Current Object") :time nil))
  (send *ol* :idle-on nil)
 ; (apply #'send *listener* :size (- (send *listener* :size) '(0 18)))
  (send *ol* :top-most t)
  (send *ol* :bottom-most nil)
  (send *ol* :no-move t)
  (send *ol* :pop-out nil)
  (send *ol* :location 0 (- (second (send *desktop-container* :size)) 11))
  (send *ol* :frame-size (first (screen-size)) 22)
  (setf *current-object-info-line* *ol*)
  )

(defun make-current-object-info-line () )

(setf *current-object-info-line* nil)

(defmeth iconmap-proto :current-object-line (&optional (text))
  (setf *bottom-line* (if text
                          text
                          (send self :draw-copyright)))
  (send self :draw-bottom-line (list " " " "))
  (send self :draw-bottom-line *bottom-line*))

(defmeth iconmap-proto :redraw-content (&key (toolbar-only))
  (send self :the-real-redraw-content :toolbar-only toolbar-only))

(defmeth iconmap-proto :the-real-redraw-content (&key (toolbar-only))
  (when *vista*
  (when (not (send self :postpone-redraw))
  (when (send *vista* :ready-to-redraw self)  
   (when (send self :gui)
     (let* ((n    (send self :num-icons))
            (icon-list (send self :icon-list))
            (redraw-order (send self :redraw-order))
            (connection-list (send self :connection-list))
            (connections-i) (k 0)
            (bc (send self :back-color))
            (dc (send self :draw-color))
            (icon)
            (y-vals (send self :y))
            (logo-at-top nil)
            (has-v-scroll (send self :has-v-scroll))
            (toolbar-length (send self :toolbar-length))
            )
      ; (setf nworkdraws (1+ nworkdraws))
      ; (FORMAT T "; WORKMAP1|REDRAW-CONTENT ~d ~d~%" nworkdraws ndrawsicon)

      ; (setf ndrawsicon 0)
       (when (> (first (send self :size)) (+ toolbar-length (if has-v-scroll 140 124)))
          (setf logo-at-top t))
       (when (and icon-list (not connection-list)) 
             (setf connection-list '((nil)))
             (send self :connection-list connection-list))
       (send self :start-buffering)
      ; (when *bottom-line* (bottom-line *bottom-line*) (send self :draw-bottom-line))
       (unless toolbar-only
               (unless logo-at-top (send self :draw-logo))
               (when (and (> n 0) icon-list)
                     (dotimes (i n)
                      (setf connections-i 
                            (select connection-list (select redraw-order i)))
                      (when (select connections-i 0)
                            (dotimes (j (length connections-i))
                             (send self :connect-icons (select redraw-order i)
                                   (select connections-i j)) ))
                      (setf icon (select icon-list (select redraw-order i)))
                      (when (not (send icon :deleted?))
                            (send icon :show-icon (if (= i (- n 1)) "selected" "normal"))
                            (when (send icon :undrawn)
                                  (send icon :show-icon 
                                        (if (= i (- n 1)) "selected" "normal"))))
                      ))
                )
       (send (first (send self :slot-value 'overlays)) :draw-toolbar)
       (when logo-at-top (send self :draw-logo))
      ; (when *bottom-line* (bottom-line) (send self :draw-bottom-line))
       (send self :draw-color dc)
       (send self :back-color bc)
       (send self :buffer-to-screen)
       )))
        (send *vista* :finished-redraw self)
        )))

(defmeth iconmap-proto :make-connection-line-list ()
  (let* ((cll nil)
         (n    (send self :num-icons))
         (icon-list (send self :icon-list))
         (redraw-order (send self :redraw-order))
         (connection-list (send self :connection-list))
         (connections-i)
         (line-list-i)
         )
    (when (and (> n 0) icon-list)
          (dotimes (i n)
                   (setf connections-i 
                         (select connection-list (select redraw-order i)))
                   (when (select connections-i 0)
                         (dotimes (j (length connections-i))
                                  (setf line-list-i 
                                        (send self :connect-icons (select redraw-order i)
                                              (select connections-i j)))
                                  (setf cll (add-element-to-list cll line-list-i))
                                  ))))
    (send self :connection-line-list cll)))

;========================================================================
; icon control methods
;========================================================================


(defmeth iconmap-proto :do-key (char shift option) 
  (when *auto-type-shift* 
        (format t "~%[ listener activated ]~%")
        (activate *listener*)
        (top-level nil)
        ; (read *standard-input* (format *standard-output* "~a~%" (string char)))
        ))

(defmeth iconmap-proto :do-click (x y m1 m2)
  (let* ((n (send self :num-icons))
         (redraw-order (send self :redraw-order))
         (i nil)
         (iconx (send self :x))
         (icony (send self :y))
         (newxy nil)
         (ix nil)
         (iy nil))
      (when (> n 0)
            (dotimes (j n)
               (setf i  (select redraw-order (- n 1 j)))
               (setf ix (select iconx i))
               (setf iy (select icony i))
               (when (and (> x ix) (< x (+ ix 45)) (> y iy) (< y (+ iy 13)))
                     (send self :select-icon i)
                     (send self :drag-icon 
                           i newxy x y iconx icony 45 13 ix iy m1)
                     (return))))))

(defmeth iconmap-proto :drag-icon 
          (i newxy x y iconx icony colpix rowpix xoff yoff shift)
;i=icon number. newxy nil. 
;x and y locations of click
;iconx icony lists of old x y locs of upleft corner all icons
;colpix rowpix=sizes of icon i
;xoff yoff=locations moving icon i from
;shift=t if move tree
  (let* ((oldlocx (select iconx i))
         (oldlocy (select icony i))
         (offsetx 0)
         (offsety 0)
         (xoff2 0)
         (added-width 0)
         (ic (select (send self :icon-list) i))
         (tw (+ 4 (send self :text-width 
                        (send self :displayed-icon-title (send ic :title)))))
         (icon-type (send ic :icon-type))
         (th (send self :text-ascent) (send self :text-descent))
         (bar-bottom (+ 30 th))
         (scrolly (second (send self :scroll)))
         )
    
    (when (or (= 1 icon-type) (< 2 icon-type 6))
          (when (send self :new-icon-style?)
                (setf added-width 34)
                (setf xoff2 -17)))
    (setf xoff2 (min xoff2 (ceiling (/ (- colpix tw) 2))))
    (setf newxy (send self :drag-grey-rect x y (max tw (+ colpix added-width))
          (+ rowpix th 5) (- x xoff xoff2) (- y yoff)))
    (when (< (first newxy) 0) (setf (first newxy) 0))
    (when (< (second newxy) 0) (setf (second newxy) 0))
    (when (and (< (second newxy) bar-bottom)
               (equal self *workmap*)
               (send self :toolbar))
          (setf (second newxy) bar-bottom))
    (setf offsetx (- oldlocx (- xoff2) (select newxy 0)))
    (setf offsety (- oldlocy (select newxy 1)))
    (send self :move-icon-tree i offsetx offsety iconx icony shift)
    (dotimes (iconnum (send self :num-icons))
             (send (select (send self :icon-list) iconnum) :moved-p nil))
    (send self :check-scroll-bars)
    (when (or (/= (- (first newxy) xoff2) xoff) 
              (/= (second newxy) yoff)
                  )
          (send self :redraw)
          )
    ))

(defmeth iconmap-proto :displayed-icon-title (title)
  (let ((L (length title))
        (short (send self :short-icon-titles))
        (minL 0)
        )
    (when short
          (setf minL (min 8 L))
          (when (= minL 8)
                (dolist (i (iseq minL L))
                        (if (< (send self :text-width (select2 title (iseq i)))
                               70)
                            (setf L i)
                            (return)))))
    (setf title (select2 title (iseq L)))
    (when (equal (select2 title (1- L)) #\-)
          (setf title (select2 title (iseq (1- L)))))
    title))

(defmeth iconmap-proto :move-icon-tree (i offsetx offsety iconx icony shift)
  (let ((icon-i (select (send self :icon-list) i))
        )
    (setf (select iconx i) (- (select iconx i) offsetx))
    (setf (select icony i) (- (select icony i) offsety))
    (send icon-i :x (select iconx i))
    (send icon-i :y (select icony i))
    (send icon-i :moved-p t)
    )
  (when shift 
        (let ((connected-icons (select (send self :connection-list) i))
              )
          (when (select connected-icons 0)
                (dolist 
                 (j connected-icons)
                 (when 
                  (not (send (select (send self :icon-list) j) :moved-p))
                  (send self :move-icon-tree 
                        j offsetx offsety iconx icony shift)))
                ))))

(defmeth iconmap-proto :select-icon (i &key (draw t))
  (when (> (send self :num-icons) 1)
        (let ((icon-number nil)
              (ix (select (send self :x) i))
              (iy (select (send self :y) i))
              (icon-list (send self :icon-list))
              (selected-icon (send self :selected-icon))
              (redraw-order (send self :redraw-order))
              (iconx (send self :x))
              (icony (send self :y))
              (draw-color (send self :draw-color))
              (icon-type (select (send self :icon-type) i))
              )
   #+color(when (and (> *color-mode* 0) (send self :use-color))
                (cond
                  ((or (= 1 icon-type) (= 4 icon-type) (= 5 icon-type))
                   (send self :draw-color 'data-icon-color))
                  ((= 2 icon-type)
                   (send self :draw-color 'tool-icon-color))
                  ((= 3 icon-type) 
                   (send self :draw-color 'model-icon-color))
                  (t 
                   (send self :draw-color 'black))))
          (when draw
                (send self :draw-icon (select icon-list selected-icon) "normal" 
                      (select iconx selected-icon)
                      (select icony selected-icon)))
          (send (select icon-list selected-icon) :icon-state "normal")
          (send self :selected-icon i);?
          (setf icon-number (send self :selected-icon))
          (when draw
                (send self :draw-icon (select icon-list i) "selected" ix iy))
          (send self :draw-color draw-color)
          (send (select icon-list i) :icon-state "selected")
          (send self :redraw-order 
                (combine (remove icon-number redraw-order) icon-number))
          )))

(defmeth iconmap-proto :locate-new-icon () ;&optional (x-boundary 0) (y-boundary 0)
  (send self :locate-unconnected-icon ))

(defmeth iconmap-proto :locate-unconnected-icon ()
  (let* ((all-x (if (send self :deleted?)
                    (select  (send self :x) 
                             (which (mapcar 'not (send self :deleted?))))
                    (send self :x)))
         (all-y (if (send self :deleted?)
                    (select  (send self :y) 
                             (which (mapcar 'not (send self :deleted?))))
                    (send self :y))))
    (send self :locate-icon 1 all-x all-y)
    ))

(defmeth iconmap-proto :add-connected-icon
  (from-icon-number title icon-type 
                    &optional data-type  
                    &key array (x-offset 0) (y-offset 0) 
                    (object nil) (implied-icon-type nil))
;(FORMAT T "~%; WORKMAP1.LSP|ADD-CONNECTED-ICON: ICON-TYPE=~A, OBJECT=~A~%" ICON-TYPE OBJECT)
  (let* ((from-icon (select (send self :icon-list) from-icon-number))
         (from-x (send from-icon :x))
         (from-y (send from-icon :y))
         (from-icon-type (send from-icon :icon-type))
         (icon-height (send from-icon :height))
         (icon-width 50)
         (to-icon nil)
         (to-icon-type icon-type)
         (to-icon-number nil)
         (to-x nil)
         (to-y nil)
         (to-xy)
      ;   (iflag nil)
         (all-x (if (send self :deleted?)
                    (select  (send self :x) 
                             (which (mapcar 'not (send self :deleted?))))
                    (send self :x)))
         (all-y (if (send self :deleted?)
                    (select  (send self :y) 
                             (which (mapcar 'not (send self :deleted?))))
                    (send self :y)))
         (vertical-seperation   27);was 19 28 23
         (horizontal-seperation (if (send self :icon-spacing?) 94 74))
         ;recently, 94, long time was 84
         (min-distance (+ icon-height vertical-seperation)) ;50
 
         (vertical-zig-zag      (if (send self :zig-zag) 13 0)); was 10
         (num-connections (length 
                           (select (send self :connection-list) from-icon-number)))
         (window-width (first (send self :size)))
         (x-offset) (y-offset) (nearest-neighbor)
         )
    (when (< window-width 0) (first (send *vista* :workmap-size)))
    (when (and (= num-connections 1) 
               (not (select 
                     (select (send self :connection-list) from-icon-number)
                     0)))
          (setf num-connections 0))
    (setf x-offset (send self :find-x-offset 
                         num-connections horizontal-seperation 
                         icon-type from-icon-type))
    (setf y-offset (+ icon-height vertical-seperation))
    (setf to-x (+ from-x x-offset))
    (setf to-y (+ from-y y-offset))
    ;(when (= 9 icon-type) (setf to-x (- to-x 10)))
    (setf nearest-neighbor
          (send self :nearest-neighbor all-y to-y all-x to-x)) 
    (when (or (> (+ to-x icon-width) window-width)
              (< nearest-neighbor min-distance))

          (setf to-xy (send self :locate-icon to-icon-type  all-x all-y from-icon))
          (setf to-x (first to-xy))
          (setf to-y (second to-xy))

          )
    (when (/= (/ num-connections 2) (floor (/ num-connections 2))) 
          (setf to-y (+ to-y vertical-zig-zag)))
    (setf to-icon (send self :add-icon self to-x to-y title 
                        icon-type data-type array :object object
                        :implied-icon-type implied-icon-type))
    (setf to-icon-number (- (send self :num-icons) 1))
    (send from-icon :icon-state "normal")
    (send from-icon :turn-title-off)
    (send from-icon :draw-title "normal")
    (send from-icon :show-icon "normal")
    (send self :connect-icons from-icon-number to-icon-number :new t)
    (send to-icon :show-icon "selected")
    to-icon
    ))



(defmeth iconmap-proto :toolbar-length ()
  (when (send self :toolbar-obj)
        (+ 100 (* 52 (send (send self :toolbar-obj) :num-icons-shown)))))


#|replace june 19 2002 with method in workmap2.lsp
(defmeth iconmap-proto :adjust-canvas-size ()
  (when (and *vista*
             (not (send self :postpone-redraw))
             (send *vista* :ready-to-redraw self)  
             (send self :gui))
        (let* (;(toolbar-length (send self :toolbar-length))
               (toolbar-length 0)
               (max-w (max (send self :x)))
               (max-h (max (send self :y)))
               (can-w (send self :canvas-width))
               (can-h (send self :canvas-height))
               (scr-flag)(scr+flag))
          (setf max-w
                (if max-w 
                    (max (+ 50 max-w) toolbar-length)
                    toolbar-length))
          (setf max-h (if max-h (+ 55 max-h) 55))
          (cond 
            ;((= can-w max-w))
            ((< can-w max-w)
             (send self :has-h-scroll max-w)
             (setf scr+flag t))
            ((>= can-w max-w)
             (send self :has-h-scroll nil)
             (setf scr-flag t)))
          (cond 
            ;((= can-h max-h))
            ((< can-h max-h)
             (send self :has-v-scroll max-h)
             (setf scr+flag t))
            ((>= can-h max-h)
             (send self :has-v-scroll nil)
             (setf scr-flag t)))
          (list (send self :canvas-width) (send self :canvas-height)))))

|#

(defmeth iconmap-proto :adjust-clip-rect ()
  (when (send self :gui)
        (let* ((vr (send self :view-rect))
               (apply #'send self :clip-rect (- (send self :view-rect) (list 0 -55 0 55)))))))

(defmeth iconmap-proto :check-scroll-bars ()
  (send self :adjust-canvas-size))


(defmeth iconmap-proto :find-x-offset 
            (num-connections horizontal-separation icon-type from-icon-type)

;(format T "~%; WORKMAP1|ICONMAP\FIND-X-OFFSET ICON-TYPE=~A FROM-ICON-TYPE=~A~%" ; ICON-TYPE FROM-ICON-TYPE)

  (let ((x-offset (* num-connections horizontal-separation)))
    (when (or (= 2 icon-type) (= 6 icon-type) (= 9 icon-type)) 
          (setf x-offset (- x-offset 10)))
    (when (or (= 2 from-icon-type) (= 6 from-icon-type) (= 9 from-icon-type))
          (setf x-offset (+ x-offset 10)))
#|
(format T "~%; WORKMAP1|ICONMAP\FIND-X-OFFSET ICON-TYPE=~A FROM-ICON-TYPE=~A X-OFFSET=~A~% "ICON-TYPE FROM-ICON-TYPE X-OFFSET)
|#
    x-offset))

         

(provide "workmap1")